perm filename XMARK.SAI[X,ALS] blob sn#087637 filedate 1974-02-20 generic text, type T, neo UTF8
00010	BEGIN "MARKX"
00020	DEFINE ⊂="COMMENT"; ⊂ NOV.26,1973;
00030	⊂ This program is a very simple pitch marking routine to be used to
00040	    suppliment Neil's routine in certain cases;
00050	DEFINE ⊃="⊂";
00060	DEFINE CR="'15",LF="'12",CRLF="CR&LF",TB="'11";
00070	LABEL STARTP,STOPP,TOFORM;
00080	 DEFINE \=" "; ⊂ DEFINE \="SAFE"; ⊂ Alternarte definitions;
00090	INTEGER SUM,SUMM,SUMP,MAX,MIN,
00100	  SUMREF,SUMSAV,SUMMIN,SUMMAX,SUMOLD;
00110	INTEGER MAXOLD,MINOLD,MARGIN,PER,PERMIN,PERMAX;
00120	INTEGER QOLD,QSAVE,QREF,QOLD2;
00130	INTEGER ZEROC,ZEROF,DX;
00140	\ INTERNAL INTEGER ARRAY FVAL,NVAL[0:8];
00150	INTEGER FX;
00160	INTEGER I,J,K,L,P,PP,Q,QQ,QNEG,QPOS,R,DK,DDK,DDDK,DVAL,DDVAL,DDDVAL,ALPHA,
00170	        POINTF,POINTX,STATE,DELTA,DELTN,VAL,CHAN1,EOF,POINTT,POINTV;
00180	INTERNAL INTEGER M,N,PERIOD;
00190	INTEGER PT0,PT1,PT2,X0,X1,Y0,Y1,X2,Y2,
00200	        PTCNT,PICK,JP,JPP,JPX,OPT,OPT1,SHUFCT;
00210	INTEGER II,JJ,KK,NN,SEGC,BRK,EOFA,EOFT,EOFTF,READ3,LFX,PITX,PITY,
00220	        SEGTOT,SEGIN,KKT,NNT,ITT,JTT,KTT;
00230	BOOLEAN ER;
00240	INTEGER CHAN3;
00250	INTERNAL INTEGER CHAN5;
00260	\ INTEGER ARRAY BUF,BUFTT[0:511];
00270	\ INTEGER ARRAY BUFT[0:1023];
00280	STRING FILEN,FILEF,READ,READ1,READT,
00290	   READTT,FILEO,READ2,FILEQ,TFILE,FILLST,FILEP;
00300	
00310	INTEGER ARRAY QRES,SUMRES,SPAN[0:7];
00320	INTEGER QX,XXP,XXM,GOOD,XING;
00330	
00340	
00350	PROCEDURE OUTALL(STRING S);
00360	BEGIN
00370	STRING SS; INTEGER J;
00380	SETBREAK(18,0,NULL,"OSN");
00390	SS←SCAN(S,18,J);
00400	OUTSTR(SS);
00410	END;
00420	
00430	PROCEDURE DATAIN;
00440	BEGIN
00450	INTEGER J;
00460	  FOR J←0 STEP 1 UNTIL 511 DO BUF[J]←0;
00470	⊂ IF EOF=0 THEN OUTSTR("BUF") ELSE OUTSTR(" EOF ");
00480	  IF EOF=0 THEN ARRYIN(CHAN1,BUF[0],512) ELSE OUTSTR("Out of data"&crlf);
00490	⊂ IF EOF=0 THEN OUTSTR(" New BUF ") ELSE OUTSTR(" EOF ");
00500	  POINTX←POINT(12,BUF[0],-1);
00510	SEGC←II←II+12; JJ←II+11;
00520	END;
00530	
00540	
00550	
00560	
00570	PROCEDURE DATOUT;
00580	BEGIN "DATOUT"
00590	INTEGER I,J;
00600	
00610	ARRYOUT(CHAN5,BUFT[0],512);
00620	FOR I←0 STEP 1 UNTIL 1023 DO BUFT[I]←0;
00630	PITX←0;
00640	END "DATOUT";
00650	
00660	
00670	
00680	
00690	PROCEDURE PEEK;
00700	BEGIN
00710	
00720	OUTSTR(CRLF&"Q'S  "&CVS(QREF)&" "&CVS(QSAVE)&" "&CVS(QOLD)&TB&"  P="&CVS(P)&
00730	  TB&"SUM'S "&CVS(SUMREF)&" "&CVS(SUMSAV)&" "&CVS(SUMOLD)&
00740	  TB&"PERIOD="&CVS(PERIOD)&" "&CVS(PER)&CRLF);
00750	END;
00760	
00770	PROCEDURE SPOR;
00780	BEGIN
00790	 OUTSTR(CVS(STATE)&" ");
00800	END;
00810	
00820	PROCEDURE PITCH;
00830	BEGIN "PITCH"
00840	
00850	CASE STATE OF BEGIN
00860	
00870	⊂ State 0	from 2 on - ;
00880	IF VAL>0 THEN BEGIN
00890	  STATE←2; QOLD←QQ; SUMP←MAX←VAL; XING←XING+1;
00900	  ⊃ SPOR;
00910	  END;
00920	
00930	⊂ STATE 1	from 5 on + ;
00940	IF VAL<0 THEN BEGIN
00950	  IF XXP<2 THEN BEGIN
00960	    STATE←5; SUM←SUM+SUMP-VAL;
00970	    ⊃ SPOR;
00980	    IF MAXOLD>MAX THEN MAX←MAXOLD;
00990	    END;
01000	  END ELSE BEGIN
01010	  SUMP←SUMP+VAL;
01020	  IF VAL>MAX THEN MAX←VAL;
01030	  IF SUMP>DELTA THEN BEGIN
01040	    STATE←2; SUM←0;
01050	    ⊃ SPOR;
01060	⊂ PEEK;
01070	    ⊂ Decision;
01080	    P←0;
01090	    IF XING≥15 THEN P←0 ELSE
01100	    IF (GOOD<2)∧(XING<5)∧(SUMOLD>SUMSAV)
01110	      THEN P←1 ELSE
01120	    IF (SUMREF=SUMSAV)∧(PER>PERIOD*3%4)∧(QOLD-QSAVE>PERIOD*3%4)
01130	      THEN P←2 ELSE
01140	    IF (SUMOLD<SUMSAV) THEN SUMSAV←SUMOLD ELSE
01150	    IF (SUMOLD>SUMSAV*4%3)∧(PER>PERIOD*7%8)∧(SUMOLD>SUMREF%2)
01160	      THEN P←3 ELSE
01170	    IF (SUMOLD>SUMSAV*5%4)∧(PER>PERIOD*9%10)∧(SUMOLD>SUMMIN)
01180	      THEN P←4 ELSE
01190	    IF (SUMREF≤SUMMIN)∧(SUMOLD>SUMREF)
01200	      THEN P←5 ELSE
01210	    IF (SUMOLD>SUMREF*5%4)∧(PER>PERIOD*5%8)
01220	      THEN P←6;	⊂ To get in step;
01230	    IF (PER>PERIOD*3%2)∧(P=0)∧(XING≤15) THEN BEGIN
01240	      K←0;
01250	      FOR I←0 STEP 1 UNTIL 7 DO
01260	        IF SUMRES[I]>K THEN BEGIN K←SUMRES[I]; QX←I; END;
01270	      IF K>2000 THEN BEGIN 
01280	        QSAVE←QRES[QX]; SUMOLD←SUMRES[QX]; P←7;
01290	        END;
01300	      END;
01310	⊃ OUTSTR(CRLF&"Q"&CVS(QSAVE)&" S"&CVS(SUMOLD)&" A"&CVS(MAXOLD-MINOLD)&" ");
01320	⊃ IF P≠0 THEN OUTSTR("P"&CVS(P)&TB);
01330	
01340	    IF ((QRES[QX]-QREF)>(PERIOD%2))∧(P=0)∧(QX<7) THEN BEGIN
01350	⊃      OUTSTR(CRLF&"QX="&CVS(QX)&TB&CVS(QRES[QX])&TB&CVS(SUMRES[QX])&TB&CVS(SPAN[QX]));
01360	      QX←QX+1;  END;
01370	    IF P>0 THEN BEGIN
01380	      GOOD←GOOD+1; XING←0;
01382	IF PITX≥2 THEN WHILE (BUFT[PITX-2] LSH -15)≥QSAVE DO BEGIN
01384	        IF PITX≥2 THEN PITX←PITX-2 ELSE DONE;; ⊂ QREF←QREF-PERIOD; END;
01390	      ⊂ Record mark;
01400	      BUFT[PITX]←(QSAVE LSH 15)+(SUMOLD LAND '77770)+(P LAND '7);
01410	      BUFT[PITX+1]←(SPAN[QX] LSH 23)+(PERIOD LSH 10)+PER;
01420	      PITX←PITX+2; IF PITX≥512 THEN DATOUT;
01430	
01440	⊂      PEEK;
01450	      SUMREF←SUMOLD; ⊂ PER←QSAVE-QREF; QREF←QSAVE;
01460	      IF (PER>PERMIN)∧(PER<PERMAX) THEN PERIOD←(2*PERIOD+PER)%3;
01470	      FOR I←0 STEP 1 UNTIL 7 DO SUMRES[I]←SPAN[I]←0;
01480	      QX←0;
01490	      JPP←0;
01500	      END;
01510	    END;
01520	  END;
01530	
01540	⊂ STATE 2	from 0 on +	from 1 on alpha with decision;
01550	IF VAL<ALPHA THEN BEGIN
01560	  QOLD←QQ-1;
01570	  IF VAL<0 THEN BEGIN STATE←0; ⊃ SPOR; END;
01580	  END  ELSE BEGIN
01590	  SUMP←SUMP+VAL; IF VAL>MAX THEN MAX←VAL;
01600	  IF SUMP>DELTA THEN BEGIN
01610	    XXM←0;
01620	    STATE←3; QRES[QX]←QSAVE←QOLD; SUMSAV←SUMOLD;
01630	    ⊃ SPOR;
01640	    END;
01650	  END;
01660	
01670	⊂ STATE 3	from 4 on +	from 2 on delta;
01680	IF VAL<0 THEN BEGIN
01690	  XXM←XXM+1;
01700	  STATE←4; SUMM←MIN←VAL; QNEG←QQ;
01710	  ⊃ SPOR;
01720	  END ELSE BEGIN
01730	  SUMP←SUMP+VAL; IF VAL>MAX THEN MAX←VAL;
01740	  END;
01750	
01760	⊂ STATE 4	from 3 on - ;
01770	IF VAL>0 THEN BEGIN
01780	  IF XXM<3 THEN BEGIN
01790	    STATE←3; SUMP←SUMP+VAL-SUMM;
01800	    ⊃ SPOR;
01810	    END;
01820	  END ELSE BEGIN
01830	  SUMM←SUMM+VAL; IF VAL<MIN THEN MIN←VAL;
01840	⊂  IF SUMM<DELTN THEN BEGIN ;
01850	   IF (XXM≥3)∨((SUMM<DELTN)∧((QQ-QNEG)>3)) THEN BEGIN 
01860	    STATE←5; SUMRES[QX]←SUM←SUMP-SUMM; SUMP←SUMM←0;
01870	    XXP←0;
01880	    ⊃ SPOR;
01890	    END;
01900	  END;
01910	
01920	⊂ STATE 5	from 2 on -	 from 4 on DELTN;
01930	IF VAL>0 THEN BEGIN
01940	  STATE←1;
01950	  XXP←XXP+1; XING←XING+1;
01960	  ⊃ SPOR;
01970	  ⊂ Prepare for decision;
01980	  MAXOLD←MAX; MINOLD←MIN; SUMRES[QX]←SUMOLD←SUM;
01990	  SPAN[QX]←MAX-MIN;
02000	  SUMP←MAX←VAL; ⊂ QSAVE←QOLD; QOLD←QQ;
02010	  PER←QSAVE-QREF;
02020	  END ELSE BEGIN
02030	  SUM←SUM-VAL; IF VAL<MIN THEN MIN←VAL;
02040	  END;
02050	END;
02060	
02070	
02080	
02090	IF ((QQ-QREF)>(PERIOD*7%4))∧(P=0) THEN BEGIN 
02100	  K←0;
02110	  FOR I←0 STEP 1 UNTIL 7 DO
02120	    IF (SUMRES[I]>K)∧(QRES[I]>(QREF+PERIOD*3%4)) THEN BEGIN K←SUMRES[I];QX←I; END;
02130	  IF (K>2000)∧(XING<15) THEN BEGIN 
02140	    QREF←QSAVE←QRES[QX]; SUMREF←SUMOLD←SUMRES[QX]; P←7;
02150	      BUFT[PITX]←(QSAVE LSH 15)+(SUMOLD LAND '77770)+(P LAND '7);
02160	      BUFT[PITX+1]←(SPAN[QX] LSH 23)+(PERIOD LSH 10)+PER;
02180	⊃    OUTSTR(CRLF&"Q"&CVS(QSAVE)&" S"&CVS(SUMOLD)&" A"&CVS(SPAN[QX])&" ");
02190	⊃    OUTSTR("*P"&CVS(P)&TB);
02200	    FOR I←0 STEP 1 UNTIL 7 DO BEGIN "SLIDE"
02210	      K←I+QX+1;
02220	      IF K≤7 THEN BEGIN
02230	        QRES[I]←QRES[K]; SUMRES[I]←SUMRES[K]; SPAN[I]←SPAN[K];
02240	        END ELSE SUMRES[I]←SPAN[I]←0;
02250	      IF SUMRES[I]=0 THEN DONE "SLIDE";
02260	      END; 
02270	    QX←I;
02280	    END ELSE BEGIN
02290	    QREF←QREF+PERIOD; GOOD←0;
02300	    BUFT[PITX]←QREF LSH 15;  PER←PERIOD;
02310	⊃    OUTSTR(CRLF&"Q"&CVS(QREF)&" ***"&TB);
02320	    END;
02325	      PITX←PITX+2; IF PITX≥512 THEN DATOUT;
02330	  XING←0;
02340	⊂  PEEK;
02350	  ⊃ SPOR;
02360	  END;
02370	
02380	QQ←QQ+1; P←0;
02390	
02400	END "PITCH";
02410	
     

00010	FILEN←"HI20.001[DAT,NJM]";
00020	FILEO←"SEG1.ASP[SYN,ALS]";
00030	PERIOD←180; PERMAX←260; PERMIN←100; MARGIN←50; DELTA←200; DELTN←-100; QQ←0;
00040	SUMMIN←200; ALPHA←100;
00050	
00060	STDBRK(1);
00070	 SETBREAK(14,"∃",NULL,"INS");
00080	 SETBREAK(15,'11&'12&'14&'15&'40,NULL,"INS");
00090	 SETBREAK(16,'56,NULL,"INA");
00100	 SETBREAK(17,'12,'15,"INS");
00110	
00120	CHAN1←1;CHAN3←3; CHAN5←5;
00130	OUTSTR("This program generates a file of pitch markers similar to "&
00140	  "the .P files"&CRLF&"    but with extension of .ASP."&CRLF);
00150	OUTSTR("At present this program takes acoustic data from [CMP,VIN],"&
00160	   CRLF&TB&CRLF&LF);
00170	
00180	
00190	STARTP:
00200	
00210	OUTSTR(CRLF&"Type number of file to start (CR only for 1) ");
00220	IF (READ←INCHWL)="" THEN PP←1 ELSE PP←CVD(READ);
00230	
00240	⊂ Begin FILEREAD;
00250	FOR PP←PP STEP 1 UNTIL 26 DO BEGIN "FILEREAD"
00260	  CLOSE(CHAN1); OPEN(CHAN1,"DSK",'10,2,0,0,0,EOF);
00270	SETFORMAT(-3,0); FILEQ←CVS(PP);
00280	  FILEN←FILEN[1 TO 5]&FILEQ&"[DAT,NJM]";
00290	LOOKUP(CHAN1,FILEN,ER); TFILE←FILEN;
00300	WHILE ER DO BEGIN
00310	   IF PP>1 THEN BEGIN OUTSTR("Out of data, will terminate."&CRLF);
00320	     GOTO STOPP; END;
00330	   OUTSTR(CRLF&"Can not find file "&TFILE&"  File= ");
00340	   LOOKUP(CHAN1,TFILE←INCHWL,ER); END;
00350	J←K←L←STATE←VAL←0; R←-1;
00360	SETFORMAT(1,0);  FILEQ←CVS(PP); JP←10000; R←-1; CLRBUF;
00370	
00380	FILEP←FILEO[1 TO 3]&FILEQ&".ASP[SYN,ALS]";
00390	CLOSE(CHAN5); OPEN(CHAN5,"DSK",'14,0,2,0,0,0);
00400	ENTER(CHAN5,FILEP,0);
00410	OUTSTR("File "&FILEP&" has been opened"&CRLF);
00420	
00430	PITX←0;
00440	SUMREF←SUMOLD←SUMSAV←SUMMIN;
00450	WHILE EOF=0 DO BEGIN
00460	DATAIN;
00470	FOR J←0 STEP 1 UNTIL 1535 DO BEGIN
00480	  VAL←ILDB(POINTX); IF VAL>2047 THEN VAL←VAL-4096;
00490	  PITCH; END;
00500	END;
00510	
00520	
     

00010	CLOSE(CHAN1); CLOSE(CHAN3);
00020	DATOUT; CLOSE(CHAN5);
00030	 IF JP<0 THEN DONE;
00040	END "FILEREAD";
00050	
00060	OUTSTR("Data are exhausted"&CRLF&LF);
00070	STOPP: PTOCHW(0,'10103); PTOCHW(0,'10120);
00080	CLOSE(CHAN1);CLOSE(CHAN3);
00090	CLOSE(CHAN5);
00100	
00110	END "MARKX";
00120